(FILECREATED "25-OCT-73 13:46:07" RECORD)


(LISPXPRINT (QUOTE RECORDVARS) T)
(RPAQQ RECORDVARS ((FNS TYPERECORD RECORD RECORD1 CLISPRECORD RECORDECL
RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 MAKECROPFN1 FIELDSIN
/PUTDTST FIELDDEFS MYSUBST MAKERPLAC2 RECRESPELL CLISPNOTRAN GETLOCALDEC
RECLOOK DWIMIFYREC EASYCOMPUTE GLOBALRECORD RECLISPLOOKUP GETSETQ
RECORDERROR SETPACK MAKEALIST CHECKDEFAULT) (PROP CLISPWORD CREATE
create USING using REUSING reusing COPYING copying) (PROP PRETTYTYPE
RECORDS) (ADDVARS (PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
(PRETTYMACROS (RECORDS X (E (MAPC (QUOTE X) (FUNCTION (LAMBDA (Z)
(PRINT (SELECTQ (CAR (SETQ Z (CLISPNOTRAN (OR (LISTP Z) (LISTP (GETP
Z (QUOTE CLISPRECORD))))))) ((RECORD TYPERECORD) Z) (ERROR Z 
"not a record")))))))))) (VARS CRLIST (RECORDSPLIST (LIST NIL)) (
CHANGEDRECLST NIL) (USERRECORDS NIL) (RECORDTRANFLG T) (
RECORDREPLACEVALUEFLG) CLISPRECORDWORDS (RECORDSUBSTFLG T)) (BLOCKS
(RECORDBLOCK TYPERECORD RECORD RECORD1 CLISPRECORD RECORDECL 
CHECKDEFAULT RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 
MAKECROPFN1 FIELDSIN /PUTDTST FIELDDEFS MYSUBST MAKERPLAC2 RECRESPELL
CLISPNOTRAN GETLOCALDEC RECLOOK DWIMIFYREC EASYCOMPUTE GLOBALRECORD
RECLISPLOOKUP GETSETQ RECORDERROR SETPACK MAKEALIST (ENTRIES RECORD
TYPERECORD RECCOMPOSE0 CLISPRECORD RECORDECL) (LOCALFREEVARS SUBSTEXPR
ALIST BLIP COPYING FIELDS DECL USINGTYPE) (GLOBALVARS CHANGEDRECLST
CLISPARRAY CLISPTRANFLG CRLIST DFNFLG DWIMFLG FILEPKGFLG 
RECORDREPLACEVALUEFLG RECORDSPLIST RECORDTRANFLG USERRECORDS 
CLISPRECORDWORDS RECORDSUBSTFLG DECLWORDS) (SPECVARS VARS REDECLARELST))
(NIL CLISPNOTRAN (LINKEDFN . T)))))
(DEFINEQ

(TYPERECORD
(NLAMBDA NAME&FIELDS (PROG (TEM) (RECORD1 (CONS (QUOTE TYPERECORD)
NAME&FIELDS)) (AND RECORDTRANFLG (/PUT (SETQ TEM (MKATOM (CONCAT (CAR
NAME&FIELDS) "?"))) (QUOTE MACRO) (CDR (/PUTDTST TEM (LIST (QUOTE
LAMBDA) (QUOTE (RECORDVAR)) (LIST (QUOTE EQ) (QUOTE (CAR RECORDVAR))
(KWOTE (CAR NAME&FIELDS)))))))) (CAR NAME&FIELDS))))

(RECORD
(NLAMBDA NAME&FIELDS (RECORD1 (CONS (QUOTE RECORD) NAME&FIELDS))))

(RECORD1
(LAMBDA (DECL) (PROG (FNF REDECLARELST TEM NAME (FAULTFN (QUOTE TYPE-IN?))
(VARS) (EXPR DECL)) RETRY (SETQ NAME (AND (NLISTP (CADR DECL)) (CADR
DECL))) (COND ((AND (NULL TEM) (NULL (CDDR DECL)) (SETQ TEM (GETP
NAME (QUOTE CLISPRECORD)))) (* Feature: saying (RECORD FOO) if FOO
has a CLISPRECORD PROP, just redeclares FOO - Useful if you edit the
property - Check for TEM keeps this from looping infinitely) (SETQ
TEM (CLISPNOTRAN TEM)) (SETQ DECL (CONS (CAR TEM) (CDR TEM))) (GO
RETRY))) (SETQ FNF (RECORDECL DECL T)) (COND (NAME (COND ((SETQ TEM
(GETP NAME (QUOTE CLISPRECORD))) (SETQ REDECLARELST (LIST (CAR (SETQ
TEM (RECORDECL TEM))) NAME)) (* REDCLARELST is used for the MAPHASH
- Here we get the RECORD name) (MAPC (CAR TEM) (FUNCTION (LAMBDA (X)
(/REMPROP X (QUOTE CLISPRECORDFIELD)) (/DREMOVE X RECORDSPLIST))))
(AND (NULL DFNFLG) (LISPXPRINT (CONS NAME (QUOTE (redeclared))) T))))
(AND (NOT (FMEMB NAME USERRECORDS)) (/RPLACA (QUOTE USERRECORDS) (CONS
NAME USERRECORDS))) (/PUT NAME (QUOTE CLISPRECORD) DECL))) (COND ((AND
FILEPKGFLG (NOT (COND (NAME (FMEMB NAME CHANGEDRECLST)) (T (MEMBER
NAME CHANGEDRECLST))))) (/RPLACA (QUOTE CHANGEDRECLST) (CONS (OR NAME
DECL) (CAR (QUOTE CHANGEDRECLST)))))) (FRPLACD (CDDR FNF) (FIELDDEFS
(CADDR FNF))) (MAPC (CDDDR FNF) (FUNCTION (LAMBDA (FIELD) (PROG NIL
(COND ((GETP (CAR FIELD) (QUOTE CLISPRECORDFIELD)) (COND (REDECLARELST
(OR (FMEMB (CAR FIELD) (CAR REDECLARELST)) (FRPLACA REDECLARELST (CONS
(CAR FIELD) (CAR REDECLARELST))))) (T (SETQ REDECLARELST (LIST (LIST
(CAR FIELD)))))) (AND (NULL DFNFLG) (LISPXPRINT (CONS (CAR FIELD)
(QUOTE (redeclared))) T)))) (ADDSPELL (CAR FIELD) RECORDSPLIST) (/PUT
(CAR FIELD) (QUOTE CLISPRECORDFIELD) DECL) (OR RECORDTRANFLG (
GLOBALRECORD FIELD)))))) (AND REDECLARELST CLISPARRAY (MAPHASH 
CLISPARRAY (FUNCTION (LAMBDA (X Y) (AND X (COND ((FMEMB (CAR Y) (QUOTE
(fetch FETCH replace REPLACE))) (FMEMB (CADR Y) (CAR REDECLARELST)))
((OR (EQ (CAR Y) (QUOTE create)) (EQ (CAR Y) (QUOTE CREATE))) (* Need
only check CREATE since RECCOMPOSE0 puts CREATE in first) (EQ (CADR
Y) (CADR REDECLARELST)))) (/PUTHASH Y NIL CLISPARRAY)))))) (RETURN
NAME))))

(CLISPRECORD
(LAMBDA (RECEXPR FIELD SETQFLG) (PROG (TEM1 DECL DECLST) (* Handles
records. When FIELD is NIL, RECEXPR is an expression such as (fetch
--) or (replace --) %. In this case, CLISPRECORD is to do the 
appropriate lookups and construct the appropriate expresson, which
it returns as its value. it should also do the hashing. Note that
even if there are no local declaration, only global ones, it shuld
still construct the expression and hash on it. If there are no local
or global declaration, return NIL. I will handle the error.) RETRY
(COND ((AND FIELD (NLISTP FIELD)) (COND ((AND (SETQ DECLST (GETLOCALDEC
EXPR FAULTFN)) (SETQ TEM1 (CLISPLOOKUP0 FIELD RECEXPR NIL DECLST NIL
(QUOTE RECORDFIELD)))) (* Local declaration, it's ok) (SETQ DECL (
RECORDECL TEM1))) ((AND (SETQ TEM1 (GETP FIELD (QUOTE ACCESSFN)))
(NLISTP FIELD)) (RETURN)) ((FMEMB FIELD (CAR (SETQ DECL (RECORDECL
(SETQ TEM1 (GETP FIELD (QUOTE CLISPRECORDFIELD))))))) (* Global 
declaration)) ((SETQ TEM1 (RECRESPELL FIELD DECLST NIL)) (SETQ FIELD
TEM1) (GO RETRY)) (T (RETURN))) (AND SETQFLG (RETURN (LIST (QUOTE
replace) FIELD TEM1 RECEXPR))) (SETQ RECEXPR (LIST (QUOTE fetch) FIELD
(QUOTE of) RECEXPR))) (SETQFLG (OR (EQ (CAR RECEXPR) (QUOTE replace))
(HELP (QUOTE (FIELD NIL OR LISTP , SETQ FLAG ON BUT NOT SECOND CALL
TO CLISPRECORD)) RECEXPR)) (* Second pass - Already done spelling
correction) (SETQ DECL (RECORDECL (SETQ TEM1 (CADDR RECEXPR)))) (FRPLACA
(CDDR RECEXPR) (QUOTE of)) (FRPLACD (CDDDR RECEXPR) (CONS (QUOTE with)
FIELD))) (T (* User typein) (SETQ TEM1 (OR (AND (SETQ DECLST (
GETLOCALDEC EXPR FAULTFN)) (CLISPLOOKUP0 (CADR RECEXPR) (CADDDR RECEXPR)
NIL DECLST NIL (QUOTE RECORDFIELD))) (GETP (CADR RECEXPR) (QUOTE 
CLISPRECORDFIELD)) (AND (RECRESPELL (CADR RECEXPR) DECLST (CDR RECEXPR))
(GO RETRY)) (RETURN))) (SELECTQ (CADDR RECEXPR) ((of OF)) (OR (FIXSPELL
(CADDR RECEXPR) 70 (QUOTE (of OF)) NIL (CDDR RECEXPR) NIL T) (RETURN)))
(SELECTQ (CAR RECEXPR) ((REPLACE replace) (SELECTQ (CAR (CDDDDR RECEXPR))
((with WITH)) (OR (FIXSPELL (CAR (CDDDDR RECEXPR)) 70 (QUOTE (with
WITH)) NIL (CDDDDR RECEXPR) NIL T) (RETURN)))) ((FETCH fetch)) (HELP
(QUOTE (FIELD NIL , SETQFLG OFF , BUT NOT BEGINNING WITH REPLACE OR
FETCH)))))) (SETQ TEM1 (OR DECL (RECORDECL TEM1) (HELP (QUOTE (NO
DECLARATION FOR THIS BUT LOOKS LIKE A VALID RECORD)) TEM1))) (* Tem1
is the GETHASH of the RECORD declaration; recexpr is the replace or
fetch expression) (OR (CDDDR TEM1) (FRPLACD (CDDR TEM1) (FIELDDEFS
(CADDR TEM1)))) (OR (SETQ TEM1 (FASSOC (CADR RECEXPR) (CDDDR TEM1)))
(HELP (QUOTE (INCONSISTANT RECORD DECLARATION)))) (CLISPTRAN RECEXPR
(SELECTQ (CAR RECEXPR) ((REPLACE replace) (OR (CDDR TEM1) (RPLACD
(CDR TEM1) (LIST (MAKERPLAC2 (CADR TEM1))))) (SETQ DECL (CONS (
RECLISPLOOKUP (CAR (SETQ TEM1 (CADDR TEM1))) (CADDDR RECEXPR) DECLST
(GETP (CAR TEM1) (QUOTE LISPFN))) (CONS (COND ((LISTP (CADR TEM1))
(PROG ((SUBSTEXPR (LIST (CADDDR RECEXPR)))) (OR (MYSUBST (CADR TEM1))
(HELP (QUOTE (NO SUBSTITUTION DONE IN RECORD EXPRESSION)))))) (T (CADDDR
RECEXPR))) (CDR (CDDDDR RECEXPR))))) (COND (RECORDREPLACEVALUEFLG
(LIST (SELECTQ (CAR DECL) ((RPLACA /RPLACA FRPLACA) (QUOTE CAR)) ((
RPLACD /RPLACD FRPLACD) (QUOTE CDR)) (HELP (QUOTE (DEFINITION OF REPLACE
IS NOT RPLACA OR RPLACD)))) DECL)) (T DECL))) ((FETCH fetch) (PROG
((SUBSTEXPR (CDDDR RECEXPR))) (OR (MYSUBST (CADR TEM1)) (HELP (QUOTE
(NO SUBSTITUTION DONE IN RECORD EXPRESSION)))))) (HELP (QUOTE (THOUGHT
I HAD A REPLACE OR FETCH HERE))))) (RETURN RECEXPR) GLOBAL2 (RETURN
(CONS (RECLISPLOOKUP (SETQ TEM1 (CAR (CDDDDR (CAR (CDDDDR RECEXPR)))))
(CADDR RECEXPR) (GETLOCALDEC EXPR FAULTFN) (GETP TEM1 (QUOTE LISPFN)))
(CONS (CADDR RECEXPR) FIELD))) GLOBAL (COND (SETQFLG (RETURN (LIST
(QUOTE replace) (QUOTE GLOBAL) RECEXPR FIELD TEM1))) ((NOT (FGETD
(SETQ TEM1 (CADDDR (FASSOC FIELD (CDDDR (RECORDECL TEM1))))))) (HELP
(QUOTE (GLOABAL RECORD WITHOUT A DEFINITION)))) (T (RETURN (LIST TEM1
RECEXPR)))))))

(RECORDECL
(LAMBDA (DECL DWIMDEFAULT) (PROG (TEM NAME FIELDS DEFAULTS) (OR (LISTP
DECL) (RETURN)) (AND (EQ (CAR DECL) CLISPTRANFLG) (OR (EQ (CADDR DECL)
(QUOTE RECORD)) (EQ (CADDR DECL) (QUOTE TYPERECORD))) (RETURN (
CHECKDEFAULT DWIMDEFAULT (CADR DECL) (CDDR DECL)))) (COND ((AND (NEQ
(CAR DECL) (QUOTE RECORD)) (NEQ (CAR DECL) (QUOTE TYPERECORD))) (RETURN)))
(AND (SETQ TEM (GETHASH DECL CLISPARRAY)) (RETURN (CHECKDEFAULT 
DWIMDEFAULT TEM DECL))) (SETQ DEFAULTS (COND ((OR (EQ (CAR DECL) (QUOTE
TYPERECORD)) (NLISTP (CADR DECL))) (SETQ NAME (CADR DECL)) (SETQ FIELDS
(CADDR DECL)) (CDDDR DECL)) (T (SETQ NAME NIL) (SETQ FIELDS (CADR
DECL)) (CDDR DECL)))) (AND (OR (LISTP NAME) (AND (NEQ (CAR DECL) (QUOTE
TYPERECORD)) (NLISTP FIELDS))) (RECORDERROR "bad record declaration"
NIL DECL)) (SETQ NAME (LIST (SETQ NAME (FIELDSIN FIELDS)) (AND DEFAULTS
(CONS (QUOTE DEFAULTNOTDWIM'D) DEFAULTS)) (COND ((EQ (CAR DECL) (QUOTE
TYPERECORD)) (CONS NIL FIELDS)) (T FIELDS)))) (CLISPTRAN DECL NAME)
(* (RECORD FOO (X . Y) DEFAULT Z:X) watch out for. thus, we put the
default thing afterwards; however -- if there is an error in the DEFAULT
stuff, we'll still have the CLISPTRAN on it; and forevermore not get
the defaults.) (RETURN (CHECKDEFAULT DWIMDEFAULT NAME DECL)))))

(RECCOMPOSE0
(LAMBDA (COMPOSESTATEMENT) (PROG (ALIST CREATE DECL DEF FIELDS TEM
TEMVAR TYPERECORDFLG USING TEM2 USINGTYPE) (* Constructs a composition
of FIELD using things from L - First L must be split up into things
in field) (SETQ CLISPCHANGE T) (* Tell DWIMIFY not to process further)
LPX (COND ((SETQ CREATE (SOME COMPOSESTATEMENT (FUNCTION (LAMBDA (X)
(AND (EQ (CAR (SETQ TEM2 (GETP X (QUOTE CLISPWORD)))) (QUOTE RECORDWORD))
(OR (EQ (SETQ TEM2 (COND ((LISTP (CDR TEM2)) (CADR TEM2)) (T (CDR
TEM2)))) (QUOTE CREATE)) (EQ TEM2 (QUOTE create)))))))) (SETQ FIELDS
(RECORDECL (SETQ DECL (RECLOOK (CADR CREATE) (CDR CREATE) (GETLOCALDEC
EXPR FAULTFN) COMPOSESTATEMENT)) T)))) (COND (TEM (OR CREATE (
RECORDERROR "no CREATE" NIL COMPOSESTATEMENT))) (T (DWIMIFYREC (CDR
COMPOSESTATEMENT) (NCONC (AND CREATE (APPEND (CAR FIELDS) (LIST (CADR
CREATE)))) (APPEND CLISPRECORDWORDS)) COMPOSESTATEMENT) (COND ((NOT
CREATE) (SETQ TEM T) (GO LPX))))) (SETQ DECL (CLISPNOTRAN DECL)) (*
DECL is the actual declaration (used for determining TYPERECORD) and
fields is the hashed declaration - (fieldlist defaults fields ...))
(SETQ TYPERECORDFLG (AND (EQ (CAR DECL) (QUOTE TYPERECORD)) (CADR
DECL))) (SETQ TEM COMPOSESTATEMENT) (SETQ ALIST (MAKEALIST (CAR FIELDS)))
LP2 (COND ((AND (NLISTP (CAR TEM)) (EQ (CAR (SETQ TEM2 (GETP (CAR
TEM) (QUOTE CLISPWORD)))) (QUOTE RECORDWORD)) (SELECTQ (SETQ TEMVAR
(COND ((LISTP (CDR TEM2)) (CADDR TEM2)) (T (CDR TEM2)))) ((CREATE
create) (* already handled) T) ((using copying reusing USING COPYING
REUSING COPYREUSING copyreusing) (AND USING (RECORDERROR (LIST (QUOTE
"both") (CAR TEM) (QUOTE "and") (CAR USING)) TEM COMPOSESTATEMENT))
(SETQ USINGTYPE TEMVAR) (SETQ USING TEM)) NIL)) (SETQ TEM (CDR TEM)))
(T (* GETSETQ adds the info to alist, or ERROR's - let it handle 
unrecognized NLISTP's as well) (GETSETQ TEM ALIST (CAR FIELDS) 
COMPOSESTATEMENT))) (COND ((SETQ TEM (CDR TEM)) (GO LP2))) (SETQ TEMVAR
NIL) (SETQ DEF (RECCOMPOSE1 (COND (TYPERECORDFLG (CDR (CADDR FIELDS)))
(T (CADDR FIELDS))) (AND USING (COND ((NOT (EASYCOMPUTE (CADR USING)))
(SETQ TEMVAR (LIST (LIST (QUOTE $$TEM) (COND (TYPERECORDFLG ('CDR
(CADR USING))) (T (CADR USING)))))) (CAAR TEMVAR)) (TYPERECORDFLG
('CDR (CADR USING))) (T (CADR USING)))))) (COND (TEMVAR (SETQ DEF
(LIST (QUOTE PROG) TEMVAR DEF)))) (/RPLNODE COMPOSESTATEMENT (CAR
CREATE) (CONS (CADR CREATE) (NCONC (COND (USING (LIST (CAR USING)
(CADR USING))) (T NIL)) (SETPACK ALIST)))) (CLISPTRAN COMPOSESTATEMENT
(COND (TYPERECORDFLG ('CONS (KWOTE TYPERECORDFLG) DEF)) (T DEF))))
COMPOSESTATEMENT))

('CAR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((NULL (SETQ TEM (CADR (FASSOC
(CAR X) CRLIST)))) (LIST (QUOTE CAR) X)) (T (LIST TEM (CADR X))))))))

('CDR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((NULL (SETQ TEM (CADDR (FASSOC
(CAR X) CRLIST)))) (LIST (QUOTE CDR) X)) (T (LIST TEM (CADR X))))))))

('CONS
(LAMBDA (CARPART CDRPART) (COND ((OR (EQ (CAR CDRPART) (QUOTE LIST))
(NOT (CAR CDRPART))) (CONS (QUOTE LIST) (CONS CARPART (CDR CDRPART))))
(T (LIST (QUOTE CONS) CARPART CDRPART)))))

(RECCOMPOSE1
(LAMBDA (FIELD DEF) (PROG (K (BLIP (CONS))) (* BLIP is used as a value
of RECCOMPOSE2 when NO field is specified, and something needs to
be returned to distinguish it from NIL (i.e. (CREATE FOO USING FIE
FUM←NIL))) (COND ((NEQ (SETQ K (RECCOMPOSE2 FIELD DEF)) BLIP) (* 
RECCOMPOSE2 returns BLIP to distinguish FIELD←NIL from the field being
not specified) K) (T (* If no USING or COPYING were specified, COPYING
NIL is assumed; thus RECCOMPOSE returning NIL means that we had a
USING) DEF)))))

(RECCOMPOSE2
(LAMBDA (FIELD DEF CDRFLG) (* Constructs the composition of FIELD
, returning NIL if none of the fields in FIELD are mentioned in the
CREATE expression and there isn't a default for any of the fields
- and <consexpression> otherwise) (PROG (TEM1 TEM2) (COND ((LISTP
FIELD) (SETQ TEM1 (RECCOMPOSE2 (CAR FIELD) ('CAR DEF))) (SETQ TEM2
(RECCOMPOSE2 (CDR FIELD) ('CDR DEF) T)) (* if both are BLIP, means
that (1) REUSING specified; (2) no fields were specified - if only
one is non-BLIP, the other comes from REUSING) (COND ((AND (EQ TEM1
BLIP) (EQ TEM2 BLIP)) BLIP) (T ('CONS (COND ((NEQ TEM1 BLIP) TEM1)
(T (SELECTQ USINGTYPE ((COPYREUSING copyreusing) (LIST (QUOTE COPY)
('CAR DEF))) ('CAR DEF)))) (COND ((NEQ TEM2 BLIP) TEM2) (T (SELECTQ
USINGTYPE ((COPYREUSING copyreusing) (LIST (QUOTE COPY) ('CDR DEF)))
('CDR DEF)))))))) ((AND FIELD (CDR (SETQ TEM1 (FASSOC FIELD ALIST))))
(* The field was specified - The SUBST here is for special option:
(create FOO using fie field1←< x ! @>) - The @ stands for fie:field1)
(COND ((AND RECORDSUBSTFLG USINGTYPE) (SUBPAIR (QUOTE @) (SELECTQ
USINGTYPE ((copying COPYING) (LIST (QUOTE COPY) DEF)) DEF) (CADR TEM1)))
(T (CADR TEM1)))) (T (SELECTQ USINGTYPE ((reusing REUSING COPYREUSING
copyreusing) (* Will get def back at higher level when it is discovered
that "other half" of the CONS is needed) BLIP) (AND (OR FIELD (NOT
CDRFLG)) (SELECTQ USINGTYPE ((using USING) DEF) ((copying COPYING)
(LIST (QUOTE COPY) DEF)) (COND ((AND FIELD (CDR (SETQ TEM1 (FASSOC
FIELD (CDADR FIELDS))))) (* The field has a default) (CADR TEM1))
(T (* There is a universal default) (CAADR FIELDS)))))))))))

(MAKECROPFN1
(LAMBDA (RCROPS) (COND ((NULL RCROPS) (QUOTE RECORDFIELDVAR)) ((NULL
(CDDDDR RCROPS)) (LIST (PACK (CONS (QUOTE C) (APPEND RCROPS (QUOTE
(R))))) (QUOTE RECORDFIELDVAR))) (T (LIST (MKATOM (CONCAT (QUOTE C)
(CAR RCROPS) (CADR RCROPS) (CADDR RCROPS) (CADDDR RCROPS) (QUOTE R)))
(MAKECROPFN1 (CDDDDR RCROPS)))))))

(FIELDSIN
(LAMBDA (X) (COND ((NULL X) NIL) ((NLISTP X) (LIST X)) (T (NCONC (
FIELDSIN (CAR X)) (FIELDSIN (CDR X)))))))

(/PUTDTST
(LAMBDA (ATM DEF) (COND ((NOT (FGETD ATM)) (/PUTD ATM DEF)) ((EQUAL
DEF (GETD ATM))) (T (VIRGINFN ATM T) (COND ((NULL DFNFLG) (LISPXPRINT
(CONS ATM (QUOTE (redefined))) T) (SAVEDEF ATM))) (/PUTD ATM DEF)))))

(FIELDDEFS
(LAMBDA (FORMAT RCROPS) (COND ((NULL FORMAT) NIL) ((LISTP FORMAT)
(NCONC (FIELDDEFS (CAR FORMAT) (CONS (QUOTE A) RCROPS)) (FIELDDEFS
(CDR FORMAT) (CONS (QUOTE D) RCROPS)))) ((LITATOM FORMAT) (LIST (LIST
FORMAT (MAKECROPFN1 RCROPS)))) (T (RECORDERROR "Invalid record field"
FORMAT DECL)))))

(MYSUBST
(LAMBDA (SEXPR) (* SUBSTS EXPR::3 for (RECORDFIELDVAR) IN SEXPR returns
NIL if RECORDFIELDVAR not found) (COND ((NLISTP SEXPR) NIL) ((EQ (CAR
SEXPR) (QUOTE RECORDFIELDVAR)) SUBSTEXPR) (T (PROG ((A (MYSUBST (CAR
SEXPR))) (D (MYSUBST (CDR SEXPR)))) (AND (NULL A) (NULL D) (RETURN))
(CONS (OR A (CAR SEXPR)) (OR D (CDR SEXPR))))))))

(MAKERPLAC2
(LAMBDA (FORM) (PROG (TEM) (OR (SETQ TEM (CDDDR (FASSOC (CAR FORM)
CRLIST))) (HELP)) (CONS (SELECTQ (CAR TEM) (CAR (QUOTE RPLACA)) (CDR
(QUOTE RPLACD)) (HELP)) (CONS (COND ((CADR TEM) (LIST (CADR TEM) (CADR
FORM))) (T (CADR FORM))) (QUOTE (VALUE)))))))

(RECRESPELL
(LAMBDA (FIELD DECLST TAIL) (FIXSPELL FIELD 70 (NCONC (MAPCONC DECLST
(FUNCTION (LAMBDA (X) (APPEND (CAR (RECORDECL X)))))) RECORDSPLIST)
NIL TAIL NIL T)))

(CLISPNOTRAN
(LAMBDA (X) (COND ((AND (LISTP X) (EQ (CAR X) CLISPTRANFLG)) (CDDR
X)) (T X))))

(GETLOCALDEC
(LAMBDA (EXPR FN) (PROG (TEM) (RETURN (COND ((AND (EQ (CAR (SETQ TEM
(CADDR EXPR))) (QUOTE *)) (EQ (CADR TEM) (QUOTE DECLARATIONS:))) (CDDR
TEM)) ((EQ (CAR TEM) (QUOTE CLISP:)) (CLISPDEC0 TEM (OR FN FAULTFN)))))))
)

(RECLOOK
(LAMBDA (RECNAME TAIL LOCALDEC PARENT) (* LOOKS FOR RECORD DECLARATION)
(PROG (TEM) RETRY (OR (COND ((NLISTP RECNAME) (OR (AND LOCALDEC (
CLISPLOOKUP0 RECNAME NIL NIL LOCALDEC NIL (QUOTE RECORD))) (GETP RECNAME
(QUOTE CLISPRECORD)) (COND ((SETQ TEM (FIXSPELL RECNAME 70 (NCONC
(MAPCONC LOCALDEC (FUNCTION (LAMBDA (X) (AND (OR (EQ (CAR X) (QUOTE
TYPERECORD)) (EQ (CAR X) (QUOTE RECORD)) (EQ (CAR X) CLISPTRANFLG))
(NLISTP (CADR X)) (LIST (CADR X)))))) USERRECORDS) NIL TAIL NIL T))
(SETQ RECNAME TEM) (GO RETRY))))) ((OR (EQ (CAR RECNAME) (QUOTE RECORD))
(EQ (CAR RECNAME) (QUOTE TYPERECORD)) (AND (EQ (CAR RECNAME) 
CLISPTRANFLG) (FMEMB (CADDR RECNAME) (QUOTE (RECORD TYPERECORD)))))
RECNAME)) (RECORDERROR (CONCAT RECNAME " not a record") NIL PARENT)))))

(DWIMIFYREC
(LAMBDA (TAIL NEWVARS PARENT) (PROG ((VARS (APPEND NEWVARS VARS)))
(AND RECORDSUBSTFLG (SETQ VARS (CONS (QUOTE @) VARS))) (DWIMIFY1B
TAIL PARENT TAIL T NIL FAULTFN))))

(EASYCOMPUTE
(LAMBDA (X) (OR (NLISTP X) (AND (SELECTQ (CAR X) ((CAR CDR) T) (GETP
(CAR X) (QUOTE CROPS))) (NLISTP (CADR X))))))

(GLOBALRECORD
(LAMBDA (FIELDS) (PROG (TEM CLASS FIELD GETFN SETFNS) (SETQ FIELD
(CAR FIELDS)) (FRPLACD (CDR FIELDS) (CONS (MAKERPLAC2 (CADR FIELDS))
(CONS (SETQ GETFN (PACK (LIST (QUOTE GET.) FIELD))) (SETQ SETFNS (LIST
(PACK (LIST (QUOTE REPLACE.) FIELD)) (PACK (LIST (QUOTE /REPLACE.)
FIELD)) (PACK (LIST (QUOTE FREPLACE.) FIELD))))))) (* now FIELDS is
(NAME DEF RPLDEF GETFN PUTFN /PUTFN FPUTFN)) (SETQ TEM (/PUT GETFN
(QUOTE MACRO) (LIST (QUOTE (RECORDFIELDVAR)) (CADR FIELDS)))) (/PUTDTST
GETFN (OR (AND (NLISTP (CADADR FIELDS)) (GETD (CAADR FIELDS))) (CONS
(QUOTE LAMBDA) TEM))) (/PUT FIELD (QUOTE ACCESSFN) GETFN) (/PUT GETFN
(QUOTE ACCESSFN) (SETQ FIELD (LIST FIELD))) (/PUT GETFN (QUOTE SETFN)
(CAR SETFNS)) (SETQ TEM (SELECTQ (CAR (CADDR FIELDS)) (RPLACA (QUOTE
(RPLACA /RPLACA FRPLACA))) (RPLACD (QUOTE (RPLACD /RPLACD FRPLACD)))
(HELP))) (/PUT (CAR SETFNS) (QUOTE LISPFN) (SELECTQ (GETP (QUOTE RPLACA)
(QUOTE LISPFN)) (RPLACA (CAR SETFNS)) (/RPLACA (CADR SETFNS)) (FRPLACA
(CADDR SETFNS)) (HELP))) (/PUT (CAR SETFNS) (QUOTE CLISPCLASSDEF)
(CONS (QUOTE ACCESS) SETFNS)) (FOR X IN TEM AS Y IN SETFNS DO (SETQ
TEM (LIST (QUOTE (RECORDFIELDVAR VALUE)) (CONS X (CDR (CADDR FIELDS)))))
(/PUTDTST Y (OR (AND (NLISTP (CADR (CADDR FIELDS))) (GETD X)) (CONS
(QUOTE LAMBDA) TEM))) (/PUT Y (QUOTE SETFN) FIELD) (/PUT Y (QUOTE
CLISPCLASS) (CAR SETFNS)) (/PUT Y (QUOTE MACRO) TEM) (AND (NOT (FMEMB
Y DECLWORDS)) (/RPLACA (QUOTE DECLWORDS) (CONS Y DECLWORDS)))))))

(RECLISPLOOKUP
(LAMBDA (WORD VAR1 DECLST LISPFN) (PROG (CLASS) (COND ((AND (SETQ
CLASS (GETP WORD (QUOTE CLISPCLASS))) DECLST) (CLISPLOOKUP0 WORD VAR1
NIL DECLST LISPFN CLASS)) (T (OR LISPFN WORD))))))

(GETSETQ
(LAMBDA (TAIL ALIST FIELDS PARENT) (PROG (TEM1) LP2 (RECORDERROR (COND
((LISTP (CAR TAIL)) (OR (SELECTQ (CAAR TAIL) ((SETQ SAVESETQ) (OR
(CDDR (CAR TAIL)) (/RPLACD (CDAR TAIL) (CONS))) NIL) ((SETQQ SAVESETQQ)
(/RPLNODE (CAR TAIL) (QUOTE SETQ) (LIST (CADAR TAIL) (KWOTE (CADDR
(CAR TAIL))))) NIL) (QUOTE NOFIELD)) (COND ((SETQ TEM1 (FASSOC (CADAR
TAIL) ALIST)) (COND ((CDR TEM1) "field specified twice") (T (RETURN
(FRPLACD TEM1 (CDDAR TAIL)))))) ((FIXSPELL (CADAR TAIL) 70 FIELDS
NIL (CDAR TAIL) NIL T) (GO LP2)) (T (QUOTE FIELDS))))) ((AND (FMEMB
(CAR TAIL) FIELDS) (COND ((AND (LISTP (CADR TAIL)) (FMEMB (CAADR TAIL)
(QUOTE (SETQ SETQQ SAVESETQ SAVESETQQ)))) (NOT (FMEMB (CADR (CADR
TAIL)) FIELDS))) (T T))) (/RPLNODE TAIL (LIST (QUOTE SETQ) (CAR TAIL)
(CADR TAIL)) (CDDR TAIL)) (GO LP2)) (T (QUOTE NOFIELDS))) (CDR TAIL)
PARENT))))

(RECORDERROR
(LAMBDA (MESSAGE AT IN) (CLISPERROR (LIST (SELECTQ MESSAGE (NOFIELDS
"missing 'field←'") (FIELDS "unrecognized field←") MESSAGE) AT IN)
T) (* Tell it that this is an external call) (ERROR!)))

(SETPACK
(LAMBDA (ALIST) (for TEM in ALIST when (CDR TEM) join (LIST (PACK
(LIST (CAR TEM) (QUOTE ←))) (CADR TEM)))))

(MAKEALIST
(LAMBDA (LST) (MAPCAR LST (FUNCTION (LAMBDA (X) (LIST X))))))

(CHECKDEFAULT
(LAMBDA (CHKFLG TRAN DECL) (AND CHKFLG (CADR TRAN) (EQ (CAADR TRAN)
(QUOTE DEFAULTNOTDWIM'D)) (PROG (ALIST (TEM (CDADR TRAN))) (DWIMIFYREC
TEM (CONS (QUOTE DEFAULT) (APPEND (CAR TRAN) NIL)) DECL) (SETQ ALIST
(CONS (LIST (QUOTE DEFAULT)) (MAKEALIST (CAR TRAN)))) LP (COND ((EQ
(CAR TEM) (QUOTE DEFAULT))) (T (GETSETQ TEM ALIST (CONS (QUOTE DEFAULT)
(CAR TRAN)) DECL))) (COND ((SETQ TEM (CDR TEM)) (GO LP))) (/RPLNODE
(CDADR TRAN) (QUOTE DEFAULT) (APPEND (COND ((CDAR ALIST) (LIST (QUOTE
←) (CADAR ALIST)))) (SETPACK (CDR ALIST)))) (FRPLACA (CDR TRAN) (CONS
(CADAR ALIST) (CDR ALIST))))) TRAN))
)
(DEFLIST(QUOTE(
(CREATE (RECORDWORD . create))
(create (RECORDWORD . create))
(USING (RECORDWORD . using))
(using (RECORDWORD . using))
(REUSING (RECORDWORD . reusing))
(reusing (RECORDWORD . reusing))
(COPYING (RECORDWORD . copying))
(copying (RECORDWORD . copying))
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
(RECORDS (LAMBDA (X Y) (AND (EQ (CAR X) Y) (CDR X))))
))(QUOTE PRETTYTYPE))

(ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
(ADDTOVAR PRETTYMACROS (RECORDS X (E (MAPC (QUOTE X) (FUNCTION (LAMBDA
(Z) (PRINT (SELECTQ (CAR (SETQ Z (CLISPNOTRAN (OR (LISTP Z) (LISTP
(GETP Z (QUOTE CLISPRECORD))))))) ((RECORD TYPERECORD) Z) (ERROR Z
"not a record")))))))))
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL) (CDR CADR CDDR CDR NIL) (CDDDDR
NIL NIL CDR CDDDR) (CADDDR NIL NIL CAR CDDDR) (CDDDR CADDDR CDDDDR
CDR CDDR) (CDADDR NIL NIL CDR CADDR) (CAADDR NIL NIL CAR CADDR) (CADDR
CAADDR CDADDR CAR CDDR) (CDDR CADDR CDDDR CDR CDR) (CDDADR NIL NIL
CDR CDADR) (CADADR NIL NIL CAR CDADR) (CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR) (CAAADR NIL NIL CAR CAADR) (CAADR CAAADR
CDAADR CAR CADR) (CADR CAADR CDADR CAR CDR) (CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR) (CDDAR CADDAR CDDDAR CDR CDAR) (CDADAR
NIL NIL CDR CADAR) (CAADAR NIL NIL CAR CADAR) (CADAR CAADAR CDADAR
CAR CDAR) (CDAR CADAR CDDAR CDR CAR) (CDDAAR NIL NIL CDR CDAAR) (CADAAR
NIL NIL CAR CDAAR) (CDAAR CADAAR CDDAAR CDR CAAR) (CDAAAR NIL NIL
CDR CAAAR) (CAAAAR NIL NIL CAR CAAAR) (CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQ RECORDSPLIST (LIST NIL))
(RPAQ CHANGEDRECLST NIL)
(RPAQ USERRECORDS NIL)
(RPAQ RECORDTRANFLG T)
(RPAQ RECORDREPLACEVALUEFLG)
(RPAQQ CLISPRECORDWORDS (CREATE USING COPYING REUSING create using
copying reusing))
(RPAQ RECORDSUBSTFLG T)
(DECLARE
(BLOCK: RECORDBLOCK TYPERECORD RECORD RECORD1 CLISPRECORD RECORDECL
CHECKDEFAULT RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 
MAKECROPFN1 FIELDSIN /PUTDTST FIELDDEFS MYSUBST MAKERPLAC2 RECRESPELL
CLISPNOTRAN GETLOCALDEC RECLOOK DWIMIFYREC EASYCOMPUTE GLOBALRECORD
RECLISPLOOKUP GETSETQ RECORDERROR SETPACK MAKEALIST (ENTRIES RECORD
TYPERECORD RECCOMPOSE0 CLISPRECORD RECORDECL) (LOCALFREEVARS SUBSTEXPR
ALIST BLIP COPYING FIELDS DECL USINGTYPE) (GLOBALVARS CHANGEDRECLST
CLISPARRAY CLISPTRANFLG CRLIST DFNFLG DWIMFLG FILEPKGFLG 
RECORDREPLACEVALUEFLG RECORDSPLIST RECORDTRANFLG USERRECORDS 
CLISPRECORDWORDS RECORDSUBSTFLG DECLWORDS) (SPECVARS VARS REDECLARELST))
(BLOCK: NIL CLISPNOTRAN (LINKEDFN . T))
)STOP